home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgramD2.iso / Borland / Borland Pascal with Objects 7.0 / COMMDLGS.ZIP / COMMDLGS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-10-27  |  9.0 KB  |  331 lines
  1. {***************************************************}
  2. {                                                   }
  3. {   Windows 3.1 Common Dialogs Demo Program         }
  4. {                                                   }
  5. {   Copyright (c) 1992 by Borland International     }
  6. {                                                   }
  7. {***************************************************}
  8.  
  9.  
  10. program CommDlgs;
  11.  
  12. {$T-}
  13.  
  14. { This program demonstrates the use of several new Windows 3.1
  15.   features: The Common Dialogs (for Font and Color selection),
  16.   True Type, and Playing sounds.
  17. }
  18.  
  19. uses WinCrt, WinDos, Strings, WinTypes, WinProcs, OWindows, ODialogs,
  20.   CommDlg, MMSystem, BWCC;
  21.  
  22. {$R CommDlgs}
  23.  
  24. const
  25.  
  26. { Resource IDs }
  27.  
  28.   id_Menu    = 100;
  29.   id_About   = 100;
  30.   id_Icon    = 100;
  31.  
  32. { Menu command IDs }
  33.  
  34.   cm_FileOpen = 101;
  35.   cm_Color    = 103;
  36.   cm_Font     = 104;
  37.   cm_Help     = 105;
  38.   cm_HelpAbout= 106;
  39.  
  40. { Other Constants }
  41.  
  42.   HelpName    = 'CommDlgs.hlp';
  43.   FlagWidth   = 251;
  44.   FlagHeight  = 180;
  45.  
  46. type
  47.  
  48. { Filename string }
  49.  
  50.   TFilename = array [0..255] of Char;
  51.  
  52. { Application main window }
  53.  
  54.   PCommDlgsWindow = ^TCommDlgsWindow;
  55.   TCommDlgsWindow = Object(TWindow)
  56.     FlagMap  : HBitMap;
  57.     TheFont  : HFont;
  58.     ALogFont : TLogFont;
  59.     ColorRef : LongInt;
  60.     FileName : TFileName;
  61.  
  62.     constructor Init(AParent: PWindowsObject; AName: PChar);
  63.     destructor  Done; virtual;
  64.  
  65.     procedure MakeDefaultFont(var AFont: HFont);
  66.     procedure SetupWindow; virtual;
  67.  
  68.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  69.  
  70.     procedure CMColor(var Msg: TMessage);
  71.       virtual cm_First + cm_Color;
  72.     procedure CMFileOpen(var Msg: TMessage);
  73.       virtual cm_First + cm_FileOpen;
  74.     procedure CMFonts(var Msg: TMessage);
  75.       virtual cm_First + cm_Font;
  76.     procedure CMHelp(var Msg: TMessage);
  77.       virtual cm_First + cm_Help;
  78.     procedure CMHelpAbout(var Msg: TMessage);
  79.       virtual cm_First + cm_HelpAbout;
  80.   end;
  81.  
  82. { Application object }
  83.  
  84.   PCommDlgApp = ^TCommDlgApp;
  85.   TCommDlgApp = Object(TApplication)
  86.     procedure InitMainWindow; virtual;
  87.   end;
  88.  
  89. { Initialized globals }
  90.  
  91. const
  92.   DemoTitle: PChar = 'Common Dialogs Demo';
  93.  
  94. { Global variables }
  95.  
  96. var
  97.   App: TCommDlgApp;
  98.  
  99.  
  100. { TCommDlgsWindow Methods }
  101.  
  102. { Constructs an instance of TCommDlgsWindow.  Loads the menu and
  103.   initialize the wave file's "FileName" and the text's initial RGB
  104.   color value.
  105. }
  106. constructor TCommDlgsWindow.Init(AParent: PWindowsObject; AName: PChar);
  107. begin
  108.   TWindow.Init(AParent, AName);
  109.   Attr.Menu:= LoadMenu(HInstance, PChar(id_Menu));
  110.  
  111.   StrCopy(FileName, '');
  112.   ColorRef := RGB(0, 0, 255);
  113.   FlagMap  := 0;
  114.   TheFont  := 0;
  115. end;
  116.  
  117. { Destroys an instance of the TCommDlgsWindow by disposing of its
  118.   "FlagMap" image and Font.  Then calls on ancestral destructor to
  119.   complete the shutdown.
  120. }
  121. destructor TCommDlgsWindow.Done;
  122. begin
  123.   if FlagMap <> 0 then
  124.     DeleteObject(FlagMap);
  125.   if TheFont <> 0 then
  126.     DeleteObject(TheFont);
  127.   TWindow.Done;
  128. end;
  129.  
  130. { Sets up an Italic, Times New Roman, font handle used as the default
  131.   Font by TCommDlgsWindow in its Paint method.
  132. }
  133. procedure TCommDlgsWindow.MakeDefaultFont(var AFont: HFont);
  134. begin
  135.   FillChar(ALogFont, SizeOf(TLogFont), #0);
  136.   with ALogFont do
  137.   begin
  138.     lfHeight        := 96;     {Make a large font                 }
  139.     lfWeight        := 700;    {Indicate a Bold attribute         }
  140.     lfItalic        := 1;      {Non-zero value indicates italic   }
  141.     lfUnderline     := 1;      {Non-zero value indicates underline}
  142.     lfOutPrecision  := Out_Stroke_Precis;
  143.     lfClipPrecision := Clip_Stroke_Precis;
  144.     lfQuality       := Default_Quality;
  145.     lfPitchAndFamily:= Variable_Pitch;
  146.     StrCopy(lfFaceName, 'Times New Roman');
  147.   end;
  148.   TheFont := CreateFontIndirect(ALogFont);
  149. end;
  150.  
  151. { Establishes the font and the "FlagMap" bitmap image used in
  152.   TCommDlgsWindow's Paint method.  The FlagMap is held as an instance
  153.   variable until the window is closed.
  154. }
  155. procedure TCommDlgsWindow.SetUpWindow;
  156. begin
  157.   TWindow.SetupWindow;
  158.   MakeDefaultFont(TheFont);
  159.   FlagMap := LoadBitmap(HInstance, 'bitmap_2');
  160. end;
  161.  
  162. { Displays the bitmap held in "FlagMap".  Then surrounds this flag map
  163.   with the string 'TP Win 3.1' in the selected font and text color.
  164. }
  165. procedure TCommDlgsWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  166. var
  167.   S        : array [0..100] of Char;
  168.   aDC      : HDC;
  169.   OldBitMap: HBitMap;
  170.   Dims     : LongInt;
  171. begin
  172.   aDC := CreateCompatibleDC(PaintDC);
  173.   OldBitMap := SelectObject(aDC, FlagMap);
  174.  
  175.   StrCopy(S, 'TP ');
  176.   SelectObject(PaintDC, TheFont);
  177.   SetTextColor(PaintDC, ColorRef);
  178.   TextOut(PaintDC, 0, 0, S, StrLen(S));
  179.  
  180.   Dims := GetTextExtent(PaintDC, S, StrLen(S));
  181.   StretchBlt(PaintDC, LoWord(Dims), 0, LoWord(Dims), HiWord(Dims),
  182.              aDC, 0, 0, FlagWidth, FlagHeight, SrcCopy);
  183.   StrCopy(S, ' Win 3.1');
  184.   TextOut(PaintDC, (LoWord(Dims) * 2), 0, S, StrLen(S));
  185.  
  186.   SelectObject(aDC, OldBitMap);
  187.   DeleteDC(aDC);
  188. end;
  189.  
  190. { Displays the "Open File Dialog" from Common dialogs and permit the user
  191.   to select from among the available Wave files.  Then play the sound
  192.   found in the file using "SndPlaySound".
  193. }
  194. procedure TCommDlgsWindow.CMFileOpen(var Msg: TMessage);
  195. const
  196.   DefExt = 'wav';
  197. var
  198.   OpenFN      : TOpenFileName;
  199.   Filter      : array [0..100] of Char;
  200.   FullFileName: TFilename;
  201.   WinDir      : array [0..145] of Char;
  202. begin
  203.   GetWindowsDirectory(WinDir, SizeOf(WinDir));
  204.   SetCurDir(WinDir);
  205.   StrCopy(FullFileName, '');
  206.  
  207. { Set up a filter buffer to look for Wave files only.  Recall that filter
  208.   buffer is a set of string pairs, with the last one terminated by a
  209.   double-null.
  210. }
  211.   FillChar(Filter, SizeOf(Filter), #0);  { Set up for double null at end }
  212.   StrCopy(Filter, 'Wave Files');
  213.   StrCopy(@Filter[StrLen(Filter)+1], '*.wav');
  214.  
  215.   FillChar(OpenFN, SizeOf(TOpenFileName), #0);
  216.   with OpenFN do
  217.   begin
  218.     hInstance     := HInstance;
  219.     hwndOwner     := HWindow;
  220.     lpstrDefExt   := DefExt;
  221.     lpstrFile     := FullFileName;
  222.     lpstrFilter   := Filter;
  223.     lpstrFileTitle:= FileName;
  224.     flags         := ofn_FileMustExist;
  225.     lStructSize   := sizeof(TOpenFileName);
  226.     nFilterIndex  := 1;       {Index into Filter String in lpstrFilter}
  227.     nMaxFile      := SizeOf(FullFileName);
  228.   end;
  229.   if GetOpenFileName(OpenFN) then
  230.     SndPlaySound(FileName, 1);   {Second parameter must be 1}
  231. end;
  232.  
  233. { Displays the "Choose Color" dialog from the common dialogs unit.
  234.   Permits an initial value to be inserted and custom colors to be
  235.   developed. Note, custom colors are not used by the "ChooseFont"
  236.   dialog from common dialogs.
  237. }
  238. procedure TCommDlgsWindow.CMColor(var Msg: TMessage);
  239. type
  240.   TLongAry = array [0..15] of Longint;
  241. const
  242.   { Establishes a set of custom colors in 15 shades of blue }
  243.   CustColors: TLongAry = (
  244.     $000000, $100000, $200000, $300000,
  245.     $400000, $500000, $600000, $700000,
  246.     $800000, $900000, $A00000, $B00000,
  247.     $C00000, $D00000, $E00000, $F00000);
  248. var
  249.   ChooseClr: TChooseColor;
  250.   i        : Integer;
  251. begin
  252.   with ChooseClr do
  253.   begin
  254.     HWndOwner   := HWindow;
  255.     lStructSize := Sizeof(TChooseColor);
  256.     rgbResult   := ColorRef;
  257.     lpCustColors:= @CustColors;
  258.     Flags       := cc_FullOpen or cc_RGBInit;
  259.       {Allow custom colors and the initialization through rgbResult}
  260.   end;
  261.   if not ChooseColor(ChooseClr) then
  262.     Exit;
  263.   ColorRef := ChooseClr.RGBResult;
  264.   InvalidateRect(HWindow, nil, True);
  265. end;
  266.  
  267. { Displays the ChooseFont dialog to permit the selection of a font which
  268.   is returned as a TLogFont.  Then a font handle is created from this
  269.   logical font information.
  270. }
  271. procedure TCommDlgsWindow.CMFonts(var Msg: TMessage);
  272. var
  273.   ChooseRec: TChooseFont;
  274.   Colors   : LongInt;
  275.   Style    : array [0..100] of Char;
  276.   TempFont : TLogFont;
  277. begin
  278.   FillChar(ChooseRec, SizeOf(ChooseRec), #0);
  279.   with ChooseRec do
  280.   begin
  281.     lStructSize:= SizeOf(TChooseFont);
  282.     hwndOwner  := HWindow;
  283.     lpLogFont  := @ALogFont;
  284.     Flags      := cf_ScreenFonts or cf_Effects or cf_InitToLogFontStruct;
  285.     rgbColors  := ColorRef;
  286.     lpszStyle  := Style;
  287.   end;
  288.   if not ChooseFont(ChooseRec) then
  289.     Exit;
  290.  
  291. { Update the Font and Color data fields, then cause the window to be
  292.   repainted.
  293. }
  294.   if TheFont <> 0 then
  295.     DeleteObject(TheFont);
  296.   ColorRef:= ChooseRec.rgbColors;
  297.   TheFont := CreateFontIndirect(ALogFont);
  298.   InvalidateRect(HWindow, nil, True);
  299. end;
  300.  
  301. { Displays the help index for the Demo Help File.
  302. }
  303. procedure TCommDlgsWindow.CMHelp(var Msg: TMessage);
  304. begin
  305.   WinHelp(HWindow, HelpName, Help_Index, 0);
  306. end;
  307.  
  308. { Displays the program's About Box dialog.
  309. }
  310. procedure TCommDlgsWindow.CMHelpAbout(var Msg: TMessage);
  311. begin
  312.   Application^.ExecDialog(New(PDialog, Init(@Self, PChar(id_About))));
  313. end;
  314.  
  315.  
  316. { TCommDlgApp Methods }
  317.  
  318. procedure TCommDlgApp.InitMainWindow;
  319. begin
  320.   MainWindow := New(PCommDlgsWindow, Init(nil, Application^.Name));
  321. end;
  322.  
  323.  
  324. { Main program }
  325.  
  326. begin
  327.   App.Init(DemoTitle);
  328.   App.Run;
  329.   App.Done;
  330. end.
  331.